home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / kcl.lha / cmpnew / cmpeval.lsp < prev    next >
Lisp/Scheme  |  1987-06-03  |  15KB  |  372 lines
  1. ;;; CMPEVAL  The Expression Dispatcher.
  2. ;;;
  3. ;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  4. ;; Copying of this file is authorized to users who have executed the true and
  5. ;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  6.  
  7. (in-package 'system)
  8.  
  9. (export '(define-compiler-macro
  10.           undef-compiler-macro
  11.           define-inline-function))
  12.  
  13. (in-package 'compiler)
  14.  
  15. (si:putprop 'progn 'c1progn 'c1special)
  16. (si:putprop 'progn 'c2progn 'c2)
  17.  
  18. (si:putprop 'si:structure-ref 'c1structure-ref 'c1)
  19. (si:putprop 'structure-ref 'c2structure-ref 'c2)
  20. (si:putprop 'structure-ref 'wt-structure-ref 'wt-loc)
  21. (si:putprop 'si:structure-set 'c1structure-set 'c1)
  22. (si:putprop 'structure-set 'c2structure-set 'c2)
  23.  
  24. (defun c1expr* (form info)
  25.   (setq form (c1expr form))
  26.   (add-info info (cadr form))
  27.   form)
  28.  
  29. (defun c1expr (form)
  30.   (setq form (catch *cmperr-tag*
  31.     (cond ((symbolp form)
  32.            (cond ((eq form nil) (c1nil))
  33.                  ((eq form t) (c1t))
  34.                  ((keywordp form)
  35.                   (list 'LOCATION (make-info :type (object-type form))
  36.                         (list 'VV (add-object form))))
  37.                  ((constantp form)
  38.                   (let ((val (symbol-value form)))
  39.                     (or (c1constant-value val nil)
  40.                         (list 'LOCATION (make-info :type (object-type val))
  41.                               (list 'VV (add-constant form))))))
  42.                  (t (c1var form))))
  43.           ((consp form)
  44.            (let ((fun (car form)))
  45.              (cond ((symbolp fun)
  46.                     (c1symbol-fun fun (cdr form)))
  47.                    ((and (consp fun) (eq (car fun) 'lambda))
  48.                     (c1lambda-fun (cdr fun) (cdr form)))
  49.                    ((and (consp fun) (eq (car fun) 'si:|#,|))
  50.                     (cmperr "Sharp-comma-macro was found in a bad place."))
  51.                    (t (cmperr "The function ~s is illegal." fun)))))
  52.           (t (c1constant-value form t)))))
  53.   (if (eq form '*cmperr-tag*) (c1nil) form))
  54.  
  55. (defvar *c1nil* (list 'LOCATION (make-info :type (object-type nil)) nil))
  56. (defun c1nil () *c1nil*)
  57. (defvar *c1t* (list 'LOCATION (make-info :type (object-type t)) t))
  58. (defun c1t () *c1t*)
  59.  
  60. (defun c1symbol-fun (fname args &aux fd)
  61.   (cond ((setq fd (get fname 'c1special)) (funcall fd args))
  62.         ((setq fd (c1local-fun fname))
  63.          (if (eq (car fd) 'call-local)
  64.              (let* ((info (make-info :sp-change t))
  65.                     (forms (c1args args info)))
  66.                   (let ((return-type (get-local-return-type (caddr fd))))
  67.                        (when return-type (setf (info-type info) return-type)))
  68.                   (let ((arg-types (get-local-arg-types (caddr fd))))
  69.                        ;;; Add type information to the arguments.
  70.                        (when arg-types
  71.                              (let ((fl nil))
  72.                                   (dolist** (form forms)
  73.                                     (cond ((endp arg-types) (push form fl))
  74.                                           (t (push (and-form-type
  75.                                                     (car arg-types) form
  76.                                                     (car args))
  77.                                                    fl)
  78.                                              (pop arg-types)
  79.                                              (pop args))))
  80.                                   (setq forms (reverse fl)))))
  81.                   (list 'call-local info (cddr fd) forms))
  82.              (c1expr (cmp-expand-macro fd fname args))))
  83.         ((and (setq fd (get fname 'c1)) (inline-possible fname))
  84.          (funcall fd args))
  85.         ((and (setq fd (get fname 'c1conditional))
  86.               (inline-possible fname)
  87.               (funcall (car fd) args))
  88.          (funcall (cdr fd) args))
  89.         ((setq fd (macro-function fname))
  90.          (c1expr (cmp-expand-macro fd fname args)))
  91.         ((setq fd (get fname 'compiler-macro))
  92.          (c1expr (cmp-eval `(funcall ',fd ',(cons fname args) nil))))
  93.         ((and (setq fd (get fname 'si::structure-access))
  94.               (inline-possible fname)
  95.               ;;; Structure hack.
  96.               (consp fd)
  97.               (si:fixnump (cdr fd))
  98.               (not (endp args))
  99.               (endp (cdr args)))
  100.          (case (car fd)
  101.                (vector (c1expr `(elt ,(car args) ,(cdr fd))))
  102.                (list (c1expr `(si:list-nth ,(cdr fd) ,(car args))))
  103.                (t (c1structure-ref1 (car args) (car fd) (cdr fd)))
  104.                )
  105.          )
  106.         ((eq fname 'si:|#,|)
  107.          (cmperr "Sharp-comma-macro was found in a bad place."))
  108.         (t (let* ((info (make-info
  109.                         :sp-change (null (get fname 'no-sp-change))))
  110.                   (forms (c1args args info)))
  111.                 (let ((return-type (get-return-type fname)))
  112.                      (when return-type (setf (info-type info) return-type)))
  113.                 (let ((arg-types (get-arg-types fname)))
  114.                      ;;; Add type information to the arguments.
  115.                      (when arg-types
  116.                        (do ((fl forms (cdr fl))
  117.                             (fl1 nil)
  118.                             (al args (cdr al)))
  119.                            ((endp fl)
  120.                             (setq forms (reverse fl1)))
  121.                            (cond ((endp arg-types) (push (car fl) fl1))
  122.                                  (t (push (and-form-type (car arg-types)
  123.                                                          (car fl)
  124.                                                          (car al))
  125.                                           fl1)
  126.                                     (pop arg-types))))))
  127.                 (let ((arg-types (get fname 'arg-types)))
  128.                      ;;; Check argument types.
  129.                      (when arg-types
  130.                            (do ((fl forms (cdr fl))
  131.                                 (al args (cdr al)))
  132.                                ((or (endp arg-types) (endp fl)))
  133.                                (check-form-type (car arg-types)
  134.                                                 (car fl) (car al))
  135.                                (pop arg-types))))
  136.                 (case fname
  137.                       (aref
  138.                        (let ((etype (info-type (cadar forms))))
  139.                             (when (or (and (eq etype 'string)
  140.                                            (setq etype 'character))
  141.                                       (and (consp etype)
  142.                                            (or (eq (car etype) 'array)
  143.                                                (eq (car etype) 'vector))
  144.                                            (setq etype (cadr etype))))
  145.                                   (setq etype
  146.                                         (type-and (info-type info) etype))
  147.                                   (when (null etype)
  148.                                         (cmpwarn
  149.                                          "Type mismatch was found in ~s."
  150.                                          (cons fname args)))
  151.                                   (setf (info-type info) etype))))
  152.                       (si:aset
  153.                        (let ((etype (info-type (cadar forms))))
  154.                             (when (or (and (eq etype 'string)
  155.                                            (setq etype 'character))
  156.                                       (and (consp etype)
  157.                                            (or (eq (car etype) 'array)
  158.                                                (eq (car etype) 'vector))
  159.                                            (setq etype (cadr etype))))
  160.                                   (setq etype
  161.                                         (type-and (info-type info)
  162.                                           (type-and (info-type
  163.                                                      (cadar (last forms)))
  164.                                                     etype)))
  165.                                   (when (null etype)
  166.                                         (cmpwarn
  167.                                          "Type mismatch was found in ~s."
  168.                                          (cons fname args)))
  169.                                   (setf (info-type info) etype)
  170.                                   (setf (info-type (cadar (last forms)))
  171.                                         etype)
  172.                                   ))))
  173.                 (list 'call-global info fname forms)))
  174.         )
  175.   )
  176.  
  177. (defun c1lambda-fun (lambda-expr args &aux (info (make-info :sp-change t)))
  178.   (setq args (c1args args info))
  179.   (setq lambda-expr (c1lambda-expr lambda-expr))
  180.   (add-info info (cadr lambda-expr))
  181.   (list 'call-lambda info lambda-expr args)
  182.   )
  183.  
  184. (defun c2expr (form)
  185.   (if (eq (car form) 'call-global)
  186.       (c2call-global (caddr form) (cadddr form) nil (info-type (cadr form)))
  187.       (apply (get (car form) 'c2) (cddr form))))
  188.  
  189. (defun c2expr* (form)
  190.   (let* ((*exit* (next-label))
  191.          (*unwind-exit* (cons *exit* *unwind-exit*)))
  192.         (c2expr form)
  193.         (wt-label *exit*))
  194.   )
  195.  
  196. (defun c2expr-top (form top &aux (*vs* 0) (*max-vs* 0) (*level* (1+ *level*))
  197.                                  (*reservation-cmacro* (next-cmacro)))
  198.   (wt-nl "{register object *base" (1- *level*) "=base;")
  199.   (base-used)
  200.   (wt-nl "{register object *base=V" top ";")
  201.   (wt-nl "register object *sup=vs_base+VM" *reservation-cmacro* ";")
  202.   (if *safe-compile*
  203.       (wt-nl "vs_reserve(VM" *reservation-cmacro* ");")
  204.       (wt-nl "vs_check;"))
  205.   (wt-nl) (reset-top)
  206.   (c2expr form)
  207.   (push (cons *reservation-cmacro* *max-vs*) *reservations*)
  208.   (wt-nl "}}")
  209.   )
  210.  
  211. (defun c2expr-top* (form top)
  212.   (let* ((*exit* (next-label))
  213.          (*unwind-exit* (cons *exit* *unwind-exit*)))
  214.         (c2expr-top form top)
  215.         (wt-label *exit*)))
  216.  
  217. (defun c1progn (forms &aux (fl nil))
  218.   (cond ((endp forms) (c1nil))
  219.         ((endp (cdr forms)) (c1expr (car forms)))
  220.         (t (let ((info (make-info)))
  221.                 (dolist (form forms)
  222.                         (setq form (c1expr form))
  223.                         (push form fl)
  224.                         (add-info info (cadr form)))
  225.                 (setf (info-type info) (info-type (cadar fl)))
  226.                 (list 'progn info (reverse fl))
  227.                 )))
  228.   )
  229.  
  230. ;;; Should be deleted.
  231. (defun c1progn* (forms info)
  232.   (setq forms (c1progn forms))
  233.   (add-info info (cadr forms))
  234.   forms)
  235.  
  236. (defun c2progn (forms)
  237.   ;;; The length of forms may not be less than 1.
  238.   (do ((l forms (cdr l)))
  239.       ((endp (cdr l))
  240.        (c2expr (car l)))
  241.       (declare (object l))
  242.       (let* ((*value-to-go* 'trash)
  243.              (*exit* (next-label))
  244.              (*unwind-exit* (cons *exit* *unwind-exit*)))
  245.             (c2expr (car l))
  246.             (wt-label *exit*)
  247.             ))
  248.   )
  249.  
  250. (defun c1args (forms info)
  251.   (mapcar #'(lambda (form) (c1expr* form info)) forms))
  252.  
  253. ;;; Structures
  254.  
  255. (defun c1structure-ref (args)
  256.   (if (and (not (endp args))
  257.            (not (endp (cdr args)))
  258.            (consp (cadr args))
  259.            (eq (caadr args) 'quote)
  260.            (not (endp (cdadr args)))
  261.            (symbolp (cadadr args))
  262.            (endp (cddadr args))
  263.            (not (endp (cddr args)))
  264.            (si:fixnump (caddr args))
  265.            (endp (cdddr args)))
  266.       (c1structure-ref1 (car args) (cadadr args) (caddr args))
  267.       (let ((info (make-info)))
  268.         (list 'call-global info 'si:structure-ref (c1args args info)))))
  269.  
  270. (defun c1structure-ref1 (form name index &aux (info (make-info)))
  271.   ;;; Explicitly called from c1expr and c1structure-ref.
  272.   (list 'structure-ref info (c1expr* form info) (add-symbol name) index))
  273.  
  274. (defun c2structure-ref (form name-vv index
  275.                              &aux (*vs* *vs*) (*inline-blocks* 0))
  276.   (let ((loc (car (inline-args (list form) '(t)))))
  277.        (unwind-exit (list 'structure-ref loc name-vv index)))
  278.   (close-inline-blocks)
  279.   )
  280.  
  281. (defun wt-structure-ref (loc name-vv index)
  282.   (if *safe-compile*
  283.       (wt "structure_ref(" loc ",VV[" name-vv "]," index ")")
  284.       (wt "(" loc ")->str.str_self[" index "]")))
  285.  
  286. (defun c1structure-set (args &aux (info (make-info)))
  287.   (if (and (not (endp args))
  288.            (not (endp (cdr args)))
  289.            (consp (cadr args))
  290.            (eq (caadr args) 'quote)
  291.            (not (endp (cdadr args)))
  292.            (symbolp (cadadr args))
  293.            (endp (cddadr args))
  294.            (not (endp (cddr args)))
  295.            (si:fixnump (caddr args))
  296.            (not (endp (cdddr args)))
  297.            (endp (cddddr args)))
  298.       (let ((x (c1expr (car args)))
  299.             (y (c1expr (cadddr args))))
  300.         (add-info info (cadr x))
  301.         (add-info info (cadr y))
  302.         (setf (info-type info) (info-type (cadr y)))
  303.         (list 'structure-set info x
  304.               (add-symbol (cadadr args)) ;;; remove QUOTE.
  305.               (caddr args) y))
  306.       (list 'call-global info 'si:structure-set (c1args args info))))
  307.  
  308. (defun c2structure-set (x name-vv index y
  309.                           &aux locs (*vs* *vs*) (*inline-blocks* 0))
  310.   (setq locs (inline-args (list x y *c1t*) '(t t t)))
  311.   (setq x (car locs))
  312.   (setq y (cadr locs))
  313.   (if *safe-compile*
  314.       (wt-nl "structure_set(" x ",VV[" name-vv "]," index "," y ");")
  315.       (wt-nl "(" x ")->str.str_self[" index "]= " y ";"))
  316.   (unwind-exit y)
  317.   (close-inline-blocks)
  318.   )
  319.  
  320. (defun c1constant-value (val always-p)
  321.   (cond
  322.    ((eq val nil) (c1nil))
  323.    ((eq val t) (c1t))
  324.    ((si:fixnump val)
  325.     (list 'LOCATION (make-info :type 'fixnum)
  326.           (list 'FIXNUM-VALUE (add-object val) val)))
  327.    ((characterp val)
  328.     (list 'LOCATION (make-info :type 'character)
  329.           (list 'CHARACTER-VALUE (add-object val) (char-code val))))
  330.    ((typep val 'long-float)
  331.     (list 'LOCATION (make-info :type 'long-float)
  332.           (list 'LONG-FLOAT-VALUE (add-object val) val)))
  333.    ((typep val 'short-float)
  334.     (list 'LOCATION (make-info :type 'short-float)
  335.           (list 'SHORT-FLOAT-VALUE (add-object val) val)))
  336.    (always-p
  337.     (list 'LOCATION (make-info :type (object-type val))
  338.           (list 'VV (add-object val))))
  339.    (t nil)))
  340.  
  341. (defmacro si::define-compiler-macro (name vl &rest body)
  342.   `(progn (si:putprop ',name
  343.                       (caddr (si:defmacro* ',name ',vl ',body))
  344.                       'compiler-macro)
  345.           ',name))  
  346.  
  347. (defun si::undef-compiler-macro (name)
  348.   (remprop name 'compiler-macro))
  349.  
  350. (defvar *compiler-temps*
  351.         '(tmp0 tmp1 tmp2 tmp3 tmp4 tmp5 tmp6 tmp7 tmp8 tmp9))
  352.  
  353. (defmacro si:define-inline-function (name vars &body body)
  354.   (let ((temps nil)
  355.         (*compiler-temps* *compiler-temps*))
  356.     (dolist (var vars)
  357.       (if (and (symbolp var)
  358.                (not (si:memq var '(&optional &rest &key &aux))))
  359.           (push (or (pop *compiler-temps*)
  360.                     (gentemp "TMP" (find-package 'compiler)))
  361.                 temps)
  362.           (error "The parameter ~s for the inline function ~s is illegal."
  363.                  var name)))
  364.     (let ((binding (cons 'list (mapcar
  365.                                 #'(lambda (var temp) `(list ',var ,temp))
  366.                                 vars temps))))
  367.       `(progn
  368.          (defun ,name ,vars ,@body)
  369.          (si:define-compiler-macro ,name ,temps
  370.            (list* 'let ,binding ',body))))))
  371.  
  372.